COMMENT ⊗   VALID 00003 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	.require "book.pub[let,jmc]" source_file
C00009 00003	(DEFUN INST (PAT EXP W)  Included to play with and show similarity to unify
C00018 ENDMK
C⊗;
.require "book.pub[let,jmc]" source_file;
.font B "ms25";
.font C "grfx25"
.font D "grfx35"
.TURN OFF "{}∂[]"
.cb	CS206	Computing with Symbolic Expressions	Spring 1977
.cb	Problem Set 2
.cb	Due May 12
.skip 2
Write and debug the following LISP functions. Submit printed output containing
a prettyprint of each function and examples showing the results of the functions.

1. Unification:

Let %2vars%1 be a list of atoms to be called variables, all others being
considered to be constants. In our examples we will take %2vars%1 = (U V W X Y
Z). An %2association list%1 or %2a-list%1 for short, is a list of pairs such that
the first element of each pair is associated with a second element which
can be any s-expression. An example of an a-list showing a possible set of
assignments for our variables could be %2w1%1 = ((X.A)(Y.(B.C))(X A B
C)(W.(X.A)).  Note that the same first element can appear in more than one
pair; the function %2assoc%1 only sees the first occurrence.
.skip 1
.nofill
The function 

%2sublis[w,x] ← %3if at %2x %3then %1{%2assoc%1[%2x,w%1]}[%2λz.%3if n %2z %3then %2x %3else d %2z%1] 
		%3else %2sublis%1[%2w,%3a %2x%1].%2sublis%1[%2w,%3d %2x%1] 
.fill
gives the result of simultaneously
substituting for the variables of %2w%1 the s-expressions that are paired with
them. Thus 

%2sublis%1[%2w1%1,(X X A W Y)] = (A A A (X.A)(B.C))

and

%2sublis%1[((X TIMES A B)(Y.C)),(PLUS X Y)] = (PLUS (TIMES A B) C).

Sublis has an inverse of sorts called inst defined as follows;

.nofill

%2inst[pat,exp,w] ←
  %3if %2w = %1NO %3then %1NO
  %3elseif at %2pat %3then 
	%2[%3if %2pat %3ε %2vars %3then %2{assoc [pat,w]}[λz.%3if n %2z %3then %2[pat.exp].w
						%3elseif d %2z %3equal %2exp %3then%2 w
						%3else %1NO]
	%3elseif %2pat %3eq %2exp %3then %2w
	%3else %1NO]
  %3elseif at %2exp %3then %1NO
  %3else %2inst[%3d %2pat, %3d %2exp, inst[%3a %2pat,%3a %2exp,w]]%1

.fill

inst is an inverse of sublis in the sense that 
%2inst[pat,exp,w] %1≠ NO implies %2sublis[inst[pat,exp,w],pat]=exp%1.

%2inst%1 and %2sublis%1 are used in programs that symbolically transform expressions
according to rules like the following:

(TIMES (PLUS X Y)(DIFFERENCE X Y)) → (DIFFERENCE (POWER X 2)(POWER Y 2)).

A related concept is called unification. We say that %2x1%1 and %2x2%1 unify to %1x%2
if there exist %2w1%1 and %2w2%1 such that:

%2x=sublis[w1,x1]=sublis[w2,x2]%1

Assuming our conventions on variables and constants, (A X) and (X B)
unify to (A B), and (A X) and (B X) don't unify. If %2x1%1 and %2x2%1 have no
variables in common, a single a-list %2w%1 can be used. We say that %2w%1 unifies
%2x1%1 and %2x2%1 to %2x%1 if and only if

%2x=sublis[w,x1]=sublis[w,x2].%1

Thus the a-list ((X.A)(Y.A)) unifies (A X) and (A Y) to (A A) and ((X.Y))
unifies them to (A Y). The latter is more general in the sense that (A A)
is an instance of (A Y) and the converse statement is not true. If %2x1%1 and
%2x2%1 unify at all, there are %2most general unifiers%1 which differ from one
another only by a renaming of the variables.

Write a LISP function for %2unify[x1,x2]%1 whose value is NO if %2x1%1 and %2x2%1 can't be
unified and a most general unifier otherwise. Examples of the function follow:

%2unify%1[(A X),(A Y)] = ((X.Y))

%2unify%1[(A (B X) Y), (A U (C V))] = ((U B X)(YC V)).

To simplify matters, you may assume that %2x1%1 and %2x2%1 have no variables in common.


2. Write a LISP function to convert a recursive function definition to a PROG
using SETQ's and GO's instead of the function calls. Design your function so
that it only makes the change when it is correct to do so.

3. The compilers described in the class notes convert a LISP program to an
assembly language form called LAP code. The conversion from this code to actual
machine code is of less theoretical interest than the compilation process, but
it is necessary to do it at some point. Write a function %2slowlap[x]%1 which takes
the LAP code produced by a compiler and returns a list of the actual code. You
can put the machine code values for the nmemonics on their property lists. This
assembler need only cover the codes necessary for the example compilation of %2alt%1
in the class notes.
(DEFUN INST (PAT EXP W) ; Included to play with and show similarity to unify
       (COND ((EQ W 'NO) 'NO)
	     ((ATOM PAT)
	      (COND ((MEMQ PAT VARS)
		     ((LAMBDA (Z) (COND ((NULL Z)
					 (CONS (CONS PAT EXP) W)
					 ((EQUAL (CDR Z) EXP) W)
					 (T 'NO)))
				  (ASSOC PAT W))))
		    ((EQ PAT EXP) W)
		    (T 'NO))
	      ((ATOM EXP) 'NO)
	      (T (INST (CDR PAT)
		       (CDR EXP)
		       (INST (CAR PAT) (CAR EXP) W)))))) 

(DEFUN FREES (E) (REMOVDUPS (FREE1 E NIL))) ; borrowed from midterm answers

(DEFUN FREE1 (E BOUND) 						       ; Looks for any variable not in Bound
       (COND ((OR (NULL E) (EQ E T) (NUMBERP E)) NIL)		       ; Ignores constants
	     ((ATOM E) (COND ((MEMBER E BOUND) NIL) (T (LIST E))))     ; collects unbound vars
	     ((OR (EQ 'GO (CAR E)) (EQ 'QUOTE (CAR E)))
	      NIL)						       ; Ignores labels in GO statements
	     ((EQ 'LAMBDA (CAR E))				       ; Collects bound vars whenever possible
	      (FREE1 (CDDR E) (APPEND (CADR E) BOUND)))
	     ((EQ 'DEFUN (CAR E))
	      (FREE1 (CDDDR E) (APPEND (CADDR E) BOUND)))
	     ((EQ 'PROG (CAR E))				       ;Calls stripatoms to avoid labels in the
	      (FREE1 (STRIPATOMS (CDDR E)) (APPEND (CADR E) BOUND)))   ;PROG
	     ((ATOM (CAR E))					       ; Takes all the arguments of function
	      (MAPCARAPP (FUNCTION FREE1) (CDR E) BOUND))	       ;but not fun name
	     (T (MAPCARAPP (FUNCTION FREE1) E BOUND)))) 	       ;Takes all elements of the list  This is
								       ;Map Car Append, like system function
								       ;MAPCAN, but with extra arguments
								       ;allowed

(DEFUN MAPCARAPP (FUN LISTARG ARG2) 
       (COND ((NULL LISTARG) NIL)
	     (T (APPEND (APPLY FUN (LIST (CAR LISTARG) ARG2))
			(MAPCARAPP FUN (CDR LISTARG) ARG2))))) 

(DEFUN REMOVDUPS (U) 						       ; Gets rid of any element that occurs
       (COND ((NULL U) NIL)					       ;later in list
	     ((MEMBER (CAR U) (CDR U)) (REMOVDUPS (CDR U)))
	     (T (CONS (CAR U) (REMOVDUPS (CDR U)))))) 		       ; Returns all of list except atoms at
								       ;top level (labels in this case)

(DEFUN STRIPATOMS (U) 
       (COND ((NULL U) NIL)
	     ((ATOM (CAR U)) (CDR U))
	     (T (CONS (CAR U) (STRIPATOMS (CDR U)))))) 

(DEFUN FRUITLOOP (X) ; Makes a prog with looping for tail recursive defuns
       (PROG (NAME CONDI ARGS) 
	     (RETURN
	      (COND ((AND (EQ (CAR X) 'DEFUN)
			  (EQ (CAR (SETQ CONDI (CADDDR X)))
			      'COND)
			  (BARECALL (SETQ NAME (CADR X)) (CDR CONDI)))
		     (LIST 'DEFUN
			   NAME
			   (SETQ ARGS (CADDR X))
			   (LIST 'PROG
				 NIL
				 NAME
				 (LIST 'RETURN
				       (CONS 'COND
					     (MAKCOND (CDR CONDI)
						      NAME
						      ARGS))))))
		    (T X))))) 

(DEFUN BARECALL (NAME CLIST) ; Spots simple tail recursion
       (COND ((NULL CLIST) NIL)
	     ((EQ NAME (CAADAR CLIST)) CLIST)
	     (T (BARECALL NAME (CDR CLIST))))) 

(DEFUN MAKCOND (CONDI NAME ARGS) ; Remakes a conditional, substituting the extra code
       (COND ((NULL CONDI) NIL)
	     ((BARECALL NAME (LIST (CAR CONDI)))
	      (CONS (FIXUPCOND (CAR CONDI) ARGS)
		    (MAKCOND (CDR CONDI) NAME ARGS)))
	     (T (CONS (CAR CONDI) (MAKCOND (CDR CONDI) NAME ARGS))))) 

(DEFUN FIXUPCOND (CPAIRS ARGS) ; Fixes a single test-result pair of a conditional
       (APPEND (LIST (CAR CPAIRS))
	       (RESETARGS ARGS (CDADR CPAIRS))
	       (LIST (LIST 'GO NAME)))) 

(DEFUN MAKSETQS (VARS VALS) ; makes a series of setqs for the args and values
       (COND ((NULL VARS) NIL)
	     (T (CONS (LIST 'SETQ (CAR VARS) (CAR VALS))
		      (MAKSETQS (CDR VARS) (CDR VALS)))))) 

(DEFUN RESETARGS (ARGS VALS) ; Reassigns the args to new value, using lambda if needed
       (COND ((NEEDLAMBDA ARGS VALS NIL) (MAKLAMBDA ARGS VALS))
	     (T (MAKSETQS ARGS VALS)))) 

(DEFUN NEEDLAMBDA (ARGS VALS CHANGED) ; Tests whether an args gets used after being reset
       (COND ((NULL ARGS) NIL)
	     ((INTERSECTION CHANGED (FREES (CAR VALS))) T)
	     (T (NEEDLAMBDA (CDR ARGS)
			    (CDR VALS)
			    (CONS (CAR ARGS) CHANGED))))) 
(DEFUN MAKLAMBDA (ARGS VALS) ; Makes a lambda to allow simultaneous resetting of args
       ((LAMBDA (GVARS) (LIST (LIST 'LAMBDA
				    GVARS
				    (MAKSETQS ARGS GVARS))
			      VALS))
	(DONTIMES (FUNCTION GENSYM) (LENGTH ARGS)))) 

(DEFUN INTERSECTION (A B) ; does simple set intersection
       (COND ((NULL A) NIL)
	     ((MEMQ (CAR A) B)
	      (CONS (CAR A) (INTERSECTION (CDR A) B)))
	     (T (INTERSECTION (CDR A) B)))) 

(DEFUN DONTIMES (FUN N) ; returns list of fun done n times
       (COND ((EQ 0. N) NIL)
	     (T (CONS (FUN) (DONTIMES FUN (- N 1.)))))) 

(DEFUN UNIFY (X1 X2) (UNIF X1 X2 '(U V W X Y Z) NIL)) ; Unifies with assumed variable convention

(DEFUN UNIF (X1 X2 VARS W) ; does the work the same way as inst
       (COND ((EQ W 'NO) 'NO)
	     ((EQUAL X1 X2) W)
	     ((OR (ATOM X1) (ATOM X2))
	      (COND ((MEMQ X1 VARS) (MASH X1 X2))
		    ((MEMQ X2 VARS) (MASH X2 X1))
		    (T 'NO)))
	     (T (UNIF (CDR X1)
		      (CDR X2)
		      VARS
		      (UNIF (CAR X1) (CAR X2) VARS W))))) 

(DEFUN MASH (ATM EXP) ; Core of inst, lifted to avoid writing twice
       ((LAMBDA (Z) (COND ((NULL Z) (CONS (CONS ATM EXP) W))
			  ((EQUAL (CDR Z) EXP) W)
			  (T 'NO)))
	(ASSOC ATM W)))